home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog5.arj / FLOW.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.4 KB  |  194 lines
  1. { flow.pas -- Display flowing animation }
  2.  
  3. program Flow;
  4.  
  5. uses WinTypes, WinProcs, WObjects;
  6.  
  7. const
  8.  
  9.   timer_ID  = 1;        { Local timer id number }
  10.   max_Index = 100;      { Maximum number of lines visible }
  11.  
  12.   dx1: Integer = 4;     { "Delta" values for controlling }
  13.   dy1: Integer = 10;    {  the animation's personality.  }
  14.   dx2: Integer = 3;
  15.   dy2: Integer = 9;
  16.  
  17. type
  18.  
  19.   LineRec = record
  20.     X1, Y1, X2, Y2 : Integer;
  21.     Color: TColorRef;
  22.   end;
  23.  
  24.   FlowApplication = object(TApplication)
  25.     procedure InitMainWindow; virtual;
  26.   end;
  27.  
  28.   PFlowWindow = ^FlowWindow;
  29.   FlowWindow = object(TWindow)
  30.     Dc: HDC;
  31.     procedure SetupWindow;
  32.       virtual;
  33.     procedure WMDestroy(var Msg: TMessage);
  34.       virtual wm_First + wm_Destroy;
  35.     procedure WMTimer(var Msg: TMessage);
  36.       virtual wm_First + wm_Timer;
  37.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  38.       virtual;
  39.   end;
  40.  
  41. var
  42.  
  43.   LineArray: array[0 .. max_Index - 1] of LineRec;
  44.   Index: Integer;     { Index for LineArray }
  45.   Erasing: Boolean;   { True if erasing old lines }
  46.  
  47.  
  48. {- Return -1 if n < 0 or +1 if n >= 0 }
  49. function Sign(n: Integer): Integer;
  50. begin
  51.   if n < 0 then Sign := -1 else Sign := 1
  52. end;
  53.  
  54. {- Create new line, direction, and color }
  55. procedure MakeNewLine(Dc: HDC; R: TRect; Index: Integer);
  56.  
  57.   procedure NewCoord(var C, Change: Integer; Max: Integer;
  58.     var color: TColorRef);
  59.   var
  60.     Temp: Integer;
  61.   begin
  62.     Temp := C + Change;
  63.     if (Temp < 0) or (Temp > Max) then
  64.     begin
  65.       Change := Sign(-Change) * (3 + Random(12));
  66.       repeat
  67.         color := RGB(Random(256), Random(256), Random(256));
  68.         color := GetNearestColor(Dc, color)
  69.       until color <> GetBkColor(Dc)
  70.     end else
  71.       C := Temp
  72.   end;
  73.  
  74. begin
  75.   with LineArray[Index] do
  76.   begin
  77.     NewCoord(x1, dx1, R.right, color);
  78.     NewCoord(y1, dy1, R.bottom, color);
  79.     NewCoord(x2, dx2, R.right, color);
  80.     NewCoord(y2, dy2, R.bottom, color)
  81.   end
  82. end;
  83.  
  84. {- Draw or erase a line identified by Index }
  85. procedure DrawLine(Dc: HDC; Index: Integer);
  86. var
  87.   OldPen, Pen: HPen;
  88.   OldROP: Integer;
  89. begin
  90.   with LineArray[Index] do
  91.   begin
  92.     Pen := CreatePen(ps_Solid, 1, color);
  93.     OldPen := SelectObject(Dc, Pen);
  94.     OldROP := SetROP2(Dc, r2_XorPen);
  95.     MoveTo(Dc, x1, y1);
  96.     LineTo(Dc, x2, y2);
  97.     SelectObject(Dc, OldPen);
  98.     DeleteObject(Pen);
  99.     SetROP2(Dc, OldROP)
  100.   end
  101. end;
  102.  
  103. { FlowApplication }
  104.  
  105. {- Initialize the application's window }
  106. procedure FlowApplication.InitMainWindow;
  107. var
  108.   I: Integer;
  109. begin
  110.   MainWindow := New(PFlowWindow, Init(nil, 'Go with the Flow'));
  111.   Randomize;
  112.   index := 0;
  113.   erasing := False;
  114.  
  115. {- Fill all x1 fields in LineArray with -1 values so the Paint
  116. method will redraw only valid lines. }
  117.  
  118.   for I := 0 to max_Index - 1 do
  119.     LineArray[I].x1 := -1
  120.  
  121. end;
  122.  
  123. { FlowWindow }
  124.  
  125. {- Initialize the window's actions }
  126. procedure FlowWindow.SetupWindow;
  127. begin
  128.   TWindow.SetupWindow;
  129.   SetTimer(hWindow, timer_ID, 1, nil)
  130. end;
  131.  
  132. {- Intercept wm_Destroy message }
  133. procedure FlowWindow.WMDestroy(var Msg: TMessage);
  134. begin
  135.   KillTimer(hWindow, timer_ID);
  136.   TWindow.WMDestroy(Msg)
  137. end;
  138.  
  139. {- Execute one "tick" of the animation }
  140. procedure FlowWindow.WMTimer(var Msg: TMessage);
  141. var
  142.   R: TRect;
  143.   S: LineRec;
  144.   I, OldIndex: Integer;
  145. begin
  146.   Dc := GetDC(hWindow);
  147.   GetClientRect(hWindow, R);
  148.   for I := 1 to 10 do
  149.   begin
  150.     OldIndex := Index;
  151.     if Index = max_Index - 1 then
  152.     begin
  153.       Index := 0;
  154.       Erasing := True
  155.     end else
  156.       inc(Index);
  157.     if Erasing then DrawLine(Dc, Index);
  158.     {- Set new lines to begin where old lines end }
  159.     LineArray[Index] := LineArray[OldIndex];
  160.     MakeNewLine(Dc, R, Index);
  161.     DrawLine(Dc, Index)
  162.   end;
  163.   ReleaseDC(hWindow, Dc)
  164. end;
  165.  
  166. {- Repaint graphics in window }
  167. procedure FlowWindow.Paint(PaintDC: HDC; var PaintInfo:
  168.   TPaintStruct);
  169. var
  170.   I: Integer;
  171.   R: TRect;
  172. begin
  173.   GetClientRect(HWindow, R);
  174.   FillRect(PaintDC, R, GetStockObject(black_Brush));
  175.   for I := 0 to max_Index - 1 do
  176.     if LineArray[I].x1 >= 0 then DrawLine(PaintDC, I)
  177. end;
  178.  
  179. var
  180.  
  181.   FlowApp: FlowApplication;
  182.  
  183. begin
  184.   FlowApp.Init('FlowApp');
  185.   FlowApp.Run;
  186.   FlowApp.Done
  187. end.
  188.  
  189.  
  190. {--------------------------------------------------------------
  191.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  192.     Revision 1.00    Date: 2/20/1991
  193. ---------------------------------------------------------------}
  194.